home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / (A)Z / (A)Z11.ADF / LOGO / LOGOSOURCE / logoop.c < prev    next >
C/C++ Source or Header  |  1987-06-29  |  11KB  |  588 lines
  1.  
  2. /*    Miscellaneous operations in LOGO.
  3.  *    Copyright (C) 1979, The Children's Museum, Boston, Mass.
  4.  *    Written by Douglas B. Klunder.
  5.  */
  6.  
  7. #include "logo.h"
  8.  
  9. struct object *true()
  10. {
  11.     return(localize(objcpstr("true")));
  12. }
  13.  
  14. struct object *false()
  15. {
  16.     return(localize(objcpstr("false")));
  17. }
  18.  
  19. obstrcmp(obj,str)
  20. register struct object *obj;
  21. char *str;
  22. {
  23.     if (!stringp(obj)) return(1);
  24.     return(strcmp(obj->obstr,str));
  25. }
  26.  
  27. int truth(x)    /* used by if handler in logo.y */
  28. register struct object *x;
  29. {
  30.     if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("If",x);
  31.     if (!obstrcmp(x,"true")) {
  32.         mfree(x);
  33.         return(1);
  34.     } else {
  35.         mfree(x);
  36.         return(0);
  37.     }
  38. }
  39.  
  40. char *mkstring(obj)
  41. register struct object *obj;
  42. {
  43.     /* subroutine for several operations which treat numbers as words,
  44.      * turn number into character string.
  45.      * Note: obj must be known to be nonempty; result is ptr to static.
  46.      */
  47.  
  48.     register char *cp;
  49.     static char str[30];
  50.  
  51.     switch(obj->obtype) {
  52.         case STRING:
  53.             cp = obj->obstr;
  54.             break;
  55.         case INT:
  56.             sprintf(str,FIXFMT,obj->obint);
  57.             cp = str;
  58.             break;
  59.         case DUB:
  60.             sprintf(str,"%g",obj->obdub);
  61.             if (!index(str,'.')) strcat(str,".0");
  62.             cp = str;
  63.             break;
  64.         default:    /* case CONS */
  65.             return(0);    /* not a string, handle uplevel */
  66.     }
  67.     return(cp);
  68. }
  69.  
  70. struct object *and(x,y)        /* both */
  71. register struct object *x,*y;
  72. {
  73.     if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("Both",x);
  74.     if (obstrcmp(y,"true") && obstrcmp(y,"false")) ungood("Both",y);
  75.     if (!obstrcmp(x,"true")) {
  76.         mfree(x);
  77.         return(y);
  78.     } else {
  79.         mfree(y);
  80.         return(x);
  81.     }
  82. }
  83.  
  84. struct object *or(x,y)        /* either */
  85. register struct object *x,*y;
  86. {
  87.     if (obstrcmp(x,"true") && obstrcmp(x,"false")) ungood("Either",x);
  88.     if (obstrcmp(y,"true") && obstrcmp(y,"false")) ungood("Either",y);
  89.     if (!obstrcmp(x,"true")) {
  90.         mfree(y);
  91.         return(x);
  92.     } else {
  93.         mfree(x);
  94.         return(y);
  95.     }
  96. }
  97.  
  98. emptyp(x)    /* non-LOGO emptyp, returning 1 if empty, 0 if not. */
  99. register struct object *x;
  100. {
  101.     if (x==0) return(1);
  102.     switch (x->obtype) {
  103.         case STRING:
  104.             if (*(x->obstr)=='\0')    /* check for character */
  105.                 return(1);
  106.         default:
  107.             return(0);
  108.     }
  109. }
  110.  
  111. struct object *lemp(x)        /* LOGO emptyp */
  112. register struct object *x;
  113. {
  114.     if (emptyp(x)) {
  115.         mfree(x);
  116.         return(true());
  117.     } else {
  118.         mfree(x);
  119.         return(false());
  120.     }
  121. }
  122.  
  123. struct object *comp(x)        /* not */
  124. register struct object *x;
  125. {
  126.     if (!obstrcmp(x,"true")) {
  127.         mfree(x);
  128.         return(false());
  129.     } else if (!obstrcmp(x,"false")) {
  130.         mfree(x);
  131.         return(true());
  132.     } else ungood("Not",x);
  133. }
  134.  
  135. struct object *lsentp(x)    /* LOGO sentencep */
  136. register struct object *x;
  137. {
  138.     register struct object *y;
  139.  
  140.     if (x==0) return(true());
  141.     if (listp(x)) {
  142.         /* BH 4/30/81 true only for a flat sentence,
  143.            not a list of lists */
  144.         for (y = x; y; y = y->obcdr)
  145.             if (listp(y->obcar)) {
  146.                 mfree(x);
  147.                 return(false());
  148.             }
  149.         mfree(x);
  150.         return(true());
  151.     } else {
  152.         mfree(x);
  153.         return(false());
  154.     }
  155. }
  156.  
  157. struct object *lwordp(x)    /* LOGO wordp */
  158. register struct object *x;
  159. {
  160.     if (!listp(x)) {
  161.         mfree(x);
  162.         return(true());
  163.     } else {
  164.         mfree(x);
  165.         return(false());
  166.     }
  167. }
  168.  
  169. struct object *first(x)        /* first */
  170. register struct object *x;
  171. {
  172.     register struct object *temp;
  173.     register char *cp;
  174.     char str[2];
  175.  
  176.     if (emptyp(x)) ungood("First",x);
  177.     if (cp = mkstring(x)) {
  178.         str[0] = *cp;
  179.         str[1] = '\0';
  180.         mfree(x);
  181.         return(localize(objcpstr(str)));
  182.     } else {
  183.         temp = x->obcar;
  184.         localize(temp);
  185.         mfree(x);
  186.         return(temp);
  187.     }
  188. }
  189.  
  190. struct object *butfir(x)        /* butfirst */
  191. register struct object *x;
  192. {
  193.     register struct object *temp;
  194.     register char *cp;
  195.  
  196.     if (emptyp(x)) ungood("Butfirst",x);
  197.     if (cp = mkstring(x)) {
  198.         cp++;    /* skip first char */
  199.         mfree(x);
  200.         return(localize(objcpstr(cp)));
  201.     } else {
  202.         temp = x->obcdr;
  203.         localize(temp);
  204.         mfree(x);
  205.         return(temp);
  206.     }
  207. }
  208.  
  209. struct object *last(x)        /* last */
  210. register struct object *x;
  211. {
  212.     register struct object *temp;
  213.     register char *cp;
  214.  
  215.     if (emptyp(x)) ungood("Last",x);
  216.     if (cp = mkstring(x)) {
  217.         mfree(x);
  218.         return(localize(objcpstr(&cp[strlen(cp)-1])));
  219.     } else {
  220.         for(temp=x; temp->obcdr; temp=temp->obcdr) ;
  221.         temp = temp->obcar;
  222.         localize(temp);
  223.         mfree(x);
  224.         return(temp);
  225.     }
  226. }
  227.  
  228. struct object *butlas(x)        /* butlast */
  229. register struct object *x;
  230. {
  231.     register struct object *temp,*temp2,*ans;
  232.     register char *cp;
  233.  
  234.     if (emptyp(x)) ungood("Butlast",x);
  235.     if (cp = mkstring(x)) {
  236.         mfree(x);
  237.         temp = objstr(ckmalloc(strlen(cp)));
  238.         strncpy(temp->obstr,cp,strlen(cp)-1);
  239.         (temp->obstr)[strlen(cp)-1] = '\0';
  240.         return(localize(temp));
  241.     } else {
  242.         if ((x->obcdr)==0) {
  243.             mfree(x);
  244.             return(0);
  245.         }
  246.         temp2 = ans = globcons(0,0);
  247.         for(temp=x; temp->obcdr->obcdr; temp=temp->obcdr) {
  248.             temp2->obcar = globcopy(temp->obcar);
  249.             temp2->obcdr = globcopy(globcons(0,0));
  250.             temp2 = temp2->obcdr;
  251.         }
  252.         temp2->obcar = globcopy(temp->obcar);
  253.         localize(ans);
  254.         mfree(x);
  255.         return(ans);
  256.     }
  257. }
  258.  
  259. struct object *fput(x,y)
  260. register struct object *x,*y;
  261. {
  262.     register struct object *z;
  263.  
  264.     if(!listp(y)) {
  265.         printf("Second input of fput must be a list.\n");
  266.         errhand();
  267.     }
  268.     z = loccons(x,y);
  269.     mfree(x);
  270.     mfree(y);
  271.     return(z);
  272. }
  273.  
  274. struct object *lput(x,y)
  275. struct object *x,*y;
  276. {
  277.     register struct object *a,*b,*ans;
  278.  
  279.     if (!listp(y)) {
  280.         printf("Second input of lput must be a list.\n");
  281.         errhand();
  282.     }
  283.     if (y == 0) {    /* 2nd input is empty list */
  284.         b = loccons(x,0);
  285.         mfree(x);
  286.         return(b);
  287.     }
  288.     ans = a = loccons(0,0);
  289.     for (b=y; b; b=b->obcdr) {
  290.         a->obcar = globcopy(b->obcar);
  291.         a->obcdr = globcopy(globcons(0,0));
  292.         a = a->obcdr;
  293.     }
  294.     a->obcar = globcopy(x);
  295.     mfree(x);
  296.     mfree(y);
  297.     return(ans);
  298. }
  299.  
  300. struct object *list(x,y)
  301. struct object *x,*y;
  302. {
  303.     register struct object *a,*b;
  304.  
  305.     b = globcons(y,0);
  306.     a = loccons(x,b);
  307.     mfree(x);
  308.     mfree(y);
  309.     return(a);
  310. }
  311.  
  312. struct object *length(x)        /* count */
  313. register struct object *x;
  314. {
  315.     register struct object *temp;
  316.     register char *cp;
  317.     register int i;
  318.  
  319.     if (x==0) return(localize(objint((FIXNUM)0)));
  320.     if (cp = mkstring(x)) {
  321.         i = strlen(cp);
  322.         mfree(x);
  323.         return(localize(objint((FIXNUM)i)));
  324.     } else {
  325.         i = 0;
  326.         for (temp=x; temp; temp = temp->obcdr)
  327.             i++;
  328.         mfree(x);
  329.         return(localize(objint((FIXNUM)i)));
  330.     }
  331. }
  332.  
  333. logois(x,y)        /* non-Logo is, despite the name */
  334. register struct object *x,*y;
  335. {
  336.     if (listp(x)) {
  337.         if (listp(y)) {
  338.             if (x==0) return(y==0);
  339.             if (y==0) return(0);
  340.             return(logois(x->obcar,y->obcar) &&
  341.                 logois(x->obcdr,y->obcdr) );
  342.         }
  343.         return(0);
  344.     }
  345.     if (listp(y)) return(0);
  346.     if (x->obtype != y->obtype) return(0);
  347.     switch (x->obtype) {
  348.         case INT:
  349.             return(x->obint == y->obint);
  350.         case DUB:
  351.             return(x->obdub == y->obdub);
  352.         default:    /* case STRING */
  353.             return(!strcmp(x->obstr,y->obstr));
  354.     }
  355. }
  356.  
  357. struct object *lis(x,y)
  358. register struct object *x,*y;
  359. {
  360.     register z;
  361.  
  362.     z = logois(x,y);
  363.     mfree(x);
  364.     mfree(y);
  365.     return(z ? true() : false());
  366. }
  367.  
  368. leq(x,y)    /* non-Logo numeric equal */
  369. register struct object *x,*y;
  370. {
  371.     NUMBER dx,dy;
  372.     FIXNUM ix,iy;
  373.     int xint,yint;
  374.  
  375.     if (listp(x) || listp(y)) return(logois(x,y));
  376.     if (stringp(x) && !nump(x)) return(logois(x,y));
  377.     if (stringp(y) && !nump(y)) return(logois(x,y));
  378.     xint = yint = 0;
  379.     if (stringp(x)) {
  380.         if (isint(x)) {
  381.             xint++;
  382.             sscanf(x->obstr,FIXFMT,&ix);
  383.         } else {
  384.             sscanf(x->obstr,EFMT,&dx);
  385.         }
  386.     } else {
  387.         if (intp(x)) {
  388.             xint++;
  389.             ix = x->obint;
  390.         } else {
  391.             dx = x->obdub;
  392.         }
  393.     }
  394.     if (stringp(y)) {
  395.         if (isint(y)) {
  396.             yint++;
  397.             sscanf(y->obstr,FIXFMT,&iy);
  398.         } else {
  399.             sscanf(y->obstr,EFMT,&dy);
  400.         }
  401.     } else {
  402.         if (intp(y)) {
  403.             yint++;
  404.             iy = y->obint;
  405.         } else {
  406.             dy = y->obdub;
  407.         }
  408.     }
  409.     if (xint != yint) {
  410.         if (xint) dx = ix;
  411.         else dy = iy;
  412.         xint = 0;
  413.     }
  414.     if (xint)
  415.         return (ix == iy);
  416.     else
  417.         return (dx == dy);
  418. }
  419.  
  420. struct object *equal(x,y)    /* Logo equalp */
  421. register struct object *x,*y;
  422. {
  423.     register z;
  424.  
  425.     z = leq(x,y);
  426.     mfree(x);
  427.     mfree(y);
  428.     return(z ? true() : false());
  429. }
  430.  
  431. struct object *worcat(x,y)    /* word */
  432. register struct object *x,*y;
  433. {
  434.     char *val,*xp,*yp;
  435.     char xstr[30],ystr[30];
  436.  
  437.     if (listp(x)) ungood("Word",x);
  438.     if (listp(y)) ungood("Word",y);
  439.     switch(x->obtype) {
  440.         case INT:
  441.             sprintf(xstr,FIXFMT,x->obint);
  442.             xp = xstr;
  443.             break;
  444.         case DUB:
  445.             sprintf(xstr,"%g",x->obdub);
  446.             if (!index(xstr,'.')) strcat(xstr,".0");
  447.             xp = xstr;
  448.             break;
  449.         default:    /* case STRING */
  450.             xp = x->obstr;
  451.     }
  452.     switch(y->obtype) {
  453.         case INT:
  454.             sprintf(ystr,FIXFMT,y->obint);
  455.             yp = ystr;
  456.             break;
  457.         case DUB:
  458.             sprintf(ystr,"%g",y->obdub);
  459.             if (!index(ystr,'.')) strcat(ystr,".0");
  460.             yp = ystr;
  461.             break;
  462.         default:    /* case STRING */
  463.             yp = y->obstr;
  464.     }
  465.     val=ckmalloc(strlen(xp)+strlen(yp)+1);
  466.     cpystr(val,xp,yp,NULL);
  467.     mfree(x);
  468.     mfree(y);
  469.     return(localize(objstr(val)));
  470. }
  471.  
  472. struct object *sencat(x,y)    /* sentence */
  473. struct object *x,*y;
  474. {
  475.     register struct object *a,*b,*c;
  476.  
  477.     if (x==0) {
  478.         if (listp(y)) return(y);
  479.         a = loccons(y,0);
  480.         mfree(y);
  481.         return(a);
  482.     }
  483.     if (listp(x)) {
  484.         c = a = globcons(0,0);
  485.         for (b=x; b->obcdr; b = b->obcdr) {
  486.             a->obcar = globcopy(b->obcar);
  487.             a->obcdr = globcopy(globcons(0,0));
  488.             a = a->obcdr;
  489.         }
  490.         a->obcar = globcopy(b->obcar);
  491.     }
  492.     else c = a = globcons(x,0);
  493.  
  494.     if (listp(y)) b = y;
  495.     else b = globcons(y,0);
  496.  
  497.     a->obcdr = globcopy(b);
  498.     mfree(x);
  499.     mfree(y);
  500.     return(localize(c));
  501. }
  502.  
  503. struct object *memberp(thing,group)
  504. struct object *thing,*group;
  505. {
  506.     register char *cp;
  507.     register struct object *rest;
  508.     int i;
  509.  
  510.     if (group==0) {
  511.         mfree(thing);
  512.         return(false());
  513.     }
  514.     if (cp = mkstring(group)) {
  515.         if (thing==0) {
  516.             mfree(group);
  517.             return(false());
  518.         }
  519.         switch (thing->obtype) {
  520.             case INT:
  521.                 if((thing->obint >= 0)&&(thing->obint < 10)) {
  522.                     i = memb('0'+thing->obint,cp);
  523.                     break;
  524.                 }
  525.             case CONS:
  526.             case DUB:
  527.                 i = 0;
  528.                 break;
  529.             default:    /* STRING */
  530.                 if (strlen(thing->obstr) == 1) {
  531.                     i = memb(*(thing->obstr),cp);
  532.                 } else i = 0;
  533.         }
  534.     } else {
  535.         i = 0;
  536.         for (rest=group; rest; rest=rest->obcdr) {
  537.             if (leq(rest->obcar,thing)) {
  538.                 i++;
  539.                 break;
  540.             }
  541.         }
  542.     }
  543.     mfree(thing);
  544.     mfree(group);
  545.     return(torf(i));
  546. }
  547.  
  548. struct object *item(num,group)
  549. struct object *num,*group;
  550. {
  551.     int inum,ernum;
  552.     register char *cp;
  553.     register struct object *rest;
  554.     char str[2];
  555.  
  556.     num = numconv(num,"Item");
  557.     if (intp(num)) inum = num->obint;
  558.     else inum = num->obdub;
  559.     if (inum <= 0) ungood("Item",num);
  560.     if (group == 0) ungood("Item",group);
  561.     if (cp = mkstring(group)) {
  562.         if (inum > strlen(cp)) {
  563.             pf1("%p has fewer than %d items.\n",group,inum);
  564.             errhand();
  565.         }
  566.         str[0] = cp[inum-1];
  567.         str[1] = '\0';
  568.         mfree(num);
  569.         mfree(group);
  570.         return(localize(objcpstr(str)));
  571.     } else {
  572.         ernum = inum;
  573.         for (rest = group; --inum; rest = rest->obcdr) {
  574.             if (rest==0) break;
  575.         }
  576.         if (rest==0) {
  577.             pf1("%p has fewer than %d items.\n",
  578.                     group,ernum);
  579.             errhand();
  580.         }
  581.         mfree(num);
  582.         rest = localize(rest->obcar);
  583.         mfree(group);
  584.         return(rest);
  585.     }
  586. }
  587.  
  588.